Shareware Grab Bag/Shareware Grab Bag.iso/011/tsr.arc/MAPMEM.PAS

Pascal/Delphi Source File | 1986-05-22 | 21.6 KB | 676 lines

{**************************************************************************
*   Maps system memory blocks for MS/PCDOS 2.0 and higher.                *
*   Also maps expanded memory allocation blocks                           *
*   Copyright (c) 1986 Kim Kokkonen, TurboPower Software.                 *
*   Released to the public domain for personal, non-commercial use only.  *
***************************************************************************
*   version 1.0 1/2/86                                                    *
*   version 1.1 1/10/86                                                   *
*     running under DOS 2.X, where block owner names are unknown          *
*   version 1.2 1/22/86                                                   *
*     a bug in parsing the owner name of the block                        *
*     a quirk in the way that the DOS PRINT buffer installs itself        *
*     minor cosmetic changes                                              *
*   version 1.3 2/6/86                                                    *
*     smarter filtering for processes that deallocate their environment   *
*   version 1.4 2/23/86                                                   *
*     add a map of Expanded memory (EMS) as well                          *
*   version 1.5 2/26/86                                                   *
*     change format of last memory block                                  *
*     change to more reliable scheme of finding first block               *
*       (thanks to Chris Dunford for pointing out a useful                *
*        undocumented DOS function).                                      *
*     support environment lengths up to 32K                               *
*   version 1.6 3/8/86                                                    *
*     support "verbose" output mode                                       *
*       display open file handles                                         *
*       show command line of each block                                   *
*   version 1.7 3/24/86                                                   *
*     work around Turbo 3.00B bug with Delete procedure and length 255    *
*     filter out command lines of programs which relocate over their      *
*       command line at PSP:$80.                                          *
*     fix treatment of handle counts from PSP                             *
*     add display of number of memory blocks per PSP to verbose mode      *
*     accept V, -V, or /V for the verbose switch                          *
*   version 1.8 4/20/86                                                   *
*     change verbose mode to show each block individually                 *
*   version 1.9 5/22/86                                                   *
*     synchronize with RELEASE                                            *
***************************************************************************
*   telephone: [phone], CompuServe: 72457,2131.                      *
*   requires Turbo version 3 to compile.                                  *
*   Compile with mAx dynamic memory = FFFF.                               *
***************************************************************************}

{$P128}

program MapMem;
  {-look at the system memory map using DOS memory control blocks}
const
  Version = '1.9';
  MaxBlocks = 100;            {max number of DOS memory blocks checked}
  MaxVector = $FF;            {highest interrupt vector checked for trapping}
type
  Block =
  record                      {store info about each memory block as it is found}
    idbyte : Byte;
    mcb : Integer;
    psp : Integer;
    len : Integer;
    psplen : Integer;
    env : Integer;
    cnt : Integer;
  end;
  BlockType = 0..MaxBlocks;
  BlockArray = array[BlockType] of Block;
  registers =
  record
    case Integer of
      1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
      2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
  end;
  Pathname = string[64];

var
  Blocks : BlockArray;
  BlockNum : BlockType;
  verbose : Boolean;
  param : Pathname;

  function StUpcase(s : Pathname) : Pathname;
    {-return the upper case of a string}
  var
    i : Byte;
  begin
    for i := 1 to Length(s) do s[i] := UpCase(s[i]);
    StUpcase := s;
  end {stupcase} ;

  procedure FindTheBlocks;
    {-scan memory for the allocated memory blocks}
  const
    MidBlockID = $4D;         {byte DOS uses to identify part of MCB chain}
    EndBlockID = $5A;         {byte DOS uses to identify last block of MCB chain}
  var
    mcbSeg : Integer;         {segment address of current MCB}
    nextSeg : Integer;        {computed segment address for the next MCB}
    gotFirst : Boolean;       {true after first MCB is found}
    gotLast : Boolean;        {true after last MCB is found}
    idbyte : Byte;            {byte that DOS uses to identify an MCB}

    function GetStartMCB : Integer;
      {-return the first MCB segment}
    var
      reg : registers;
    begin
      reg.ah := $52;
      MsDos(reg);
      GetStartMCB := MemW[reg.es:(reg.bx-2)];
    end {getstartmcb} ;

    procedure StoreTheBlock(var mcbSeg, nextSeg : Integer;
                            var gotFirst, gotLast : Boolean);
      {-store information regarding the memory block}
    var
      nextID : Byte;
      pspAdd : Integer;       {segment address of the current PSP}
      mcbLen : Integer;       {size of the current memory block in paragraphs}

    begin

      mcbLen := MemW[mcbSeg:3]; {size of the MCB in paragraphs}
      nextSeg := Succ(mcbSeg+mcbLen); {where the next MCB should be}
      pspAdd := MemW[mcbSeg:1]; {address of program segment prefix for MCB}
      nextID := Mem[nextSeg:0];

      if gotLast or (nextID = EndBlockID) or (nextID = MidBlockID) then begin
        BlockNum := Succ(BlockNum);
        gotFirst := True;
        with Blocks[BlockNum] do begin
          idbyte := Mem[mcbSeg:0];
          mcb := mcbSeg;
          psp := pspAdd;
          env := MemW[pspAdd:$2C];
          len := mcbLen;
          psplen := 0;
          cnt := 1;
        end;
      end;

    end {storetheblock} ;

  begin

    {initialize}
    mcbSeg := GetStartMCB;
    gotFirst := False;
    gotLast := False;
    BlockNum := 0;

    {scan all memory until the last block is found}
    repeat
      idbyte := Mem[mcbSeg:0];
      if idbyte = MidBlockID then begin
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
        if gotFirst then mcbSeg := nextSeg else mcbSeg := Succ(mcbSeg);
      end else if gotFirst and (idbyte = EndBlockID) then begin
        gotLast := True;
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
      end else begin
        {start block was invalid}
        WriteLn('corrupted allocation chain or program error');
        Halt(1);
      end;
    until gotLast;

  end {findtheblocks} ;

  function Cardinal(i : Integer) : Real;
    {-return an unsigned integer 0..65535}
  begin
    Cardinal := 256.0*Hi(i)+Lo(i);
  end {cardinal} ;

  procedure StripNonAscii(var t : Pathname);
    {-return an empty string if t contains any non-printable characters}
  var
    ipos : Byte;
    goodname : Boolean;
  begin
    goodname := True;
    for ipos := 1 to Length(t) do
      if (t[ipos] <> #0) and ((t[ipos] < ' ') or (t[ipos] > '}')) then
        goodname := False;
    if not(goodname) then t := '';
  end {stripnonascii} ;

  procedure ShowTheBlocks;
    {-analyze and display the blocks found}
  type
    HexString = string[4];
    Address = record
                offset, segment : Integer;
              end;
    VectorType = 0..MaxVector;
  var
    st, cline : Pathname;
    b : BlockType;
    StLen, DOSv : Byte;
    CommandPSP : Integer;
    Vectors : array[VectorType] of Address absolute 0 : 0;
    Vtable : array[VectorType] of Real;
    SumNum : BlockType;
    Sum : BlockArray;

    function Hex(i : Integer) : HexString;
      {-return hex representation of integer}
    const
      hc : array[0..15] of Char = '0123456789ABCDEF';
    var
      l, h : Byte;
    begin
      l := Lo(i); h := Hi(i);
      Hex := hc[h shr 4]+hc[h and $F]+hc[l shr 4]+hc[l and $F];
    end {hex} ;

    function DOSversion : Byte;
      {-return the major version number of DOS}
    var
      reg : registers;
    begin
      reg.ah := $30;
      MsDos(reg);
      DOSversion := reg.al;
    end {dosversion} ;

    function Owner(startadd : Integer) : Pathname;
      {-return the name of the owner program of an MCB}
    type
      chararray = array[0..32767] of Char;
    var
      e : ^chararray;
      i : Integer;
      t : Pathname;

      function LongPos(m : Pathname; var s : chararray) : Integer;
        {-return the position number of m in s, or 0 if not found}
      var
        mc : Char;
        ss : Pathname;
        i, maxindex : Integer;
        found : Boolean;
      begin
        i := 0;
        maxindex := SizeOf(s)-Length(m);
        ss[0] := m[0];
        if Length(m) > 0 then begin
          mc := m[1];
          repeat
            while (s[i] <> mc) and (i <= maxindex) do
              i := Succ(i);
            if s[i] = mc then begin
              Move(s[i], ss[1], Length(m));
              found := (ss = m);
              if not(found) then i := Succ(i);
            end;
          until found or (i > maxindex);
          if not(found) then i := 0;
        end;
        LongPos := i;
      end {longpos} ;

      procedure StripPathname(var pname : Pathname);
        {-remove leading drive or path name from the input}
      var
        spos, cpos, rpos : Byte;
      begin
        spos := Pos('\', pname);
        cpos := Pos(':', pname);
        if spos+cpos = 0 then Exit;
        if spos <> 0 then begin
          {find the last slash in the pathname}
          rpos := Length(pname);
          while (rpos > 0) and (pname[rpos] <> '\') do rpos := Pred(rpos);
        end else
          rpos := cpos;
        Delete(pname, 1, rpos);
      end {strippathname} ;

      procedure StripExtension(var pname : Pathname);
        {-remove the file extension}
      var
        dotpos : Byte;
      begin
        dotpos := Pos('.', pname);
        if dotpos <> 0 then
          Delete(pname, dotpos, 64); {<255 needed for Turbo version 3.00B bug}
      end {stripextension} ;

    begin
      {point to the environment string}
      e := Ptr(startadd, 0);

      {find end of the standard environment}
      i := LongPos(#0#0, e^);
      if i = 0 then begin
        {something's wrong, exit gracefully}
        Owner := '';
        Exit;
      end;

      {end of environment found, get the program name that follows it}
      t := '';
      i := i+4;               {skip over #0#0#args}
      repeat
        t := t+e^[i];
        i := Succ(i);
      until (Length(t) > 64) or (e^[i] = #0);

      StripNonAscii(t);
      if t = '' then
        Owner := 'N/A'
      else begin
        StripPathname(t);
        StripExtension(t);
        if t = '' then t := 'N/A';
        Owner := StUpcase(t);
      end;

    end {owner} ;

    procedure InitVectorTable;
      {-build real equivalent of vector addresses}
    var
      v : VectorType;

      function RealAdd(a : Address) : Real;
        {-return the real equivalent of an address (pointer)}
      begin
        with a do
          RealAdd := 16.0*Cardinal(segment)+Cardinal(offset);
      end {realadd} ;

    begin
      for v := 0 to MaxVector do
        Vtable[v] := RealAdd(Vectors[v]);
    end {initvectortable} ;

    procedure WriteHooks(start, stop : Integer);
      {-show the trapped interrupt vectors}
    var
      v : VectorType;
      sadd, eadd : Real;
    begin
      if start = stop then Exit;
      sadd := 16.0*Cardinal(start);
      eadd := 16.0*Cardinal(stop);
      for v := 0 to MaxVector do begin
        if (Vtable[v] >= sadd) and (Vtable[v] <= eadd) then
          Write(Copy(Hex(v), 3, 2), ' ');
      end;
    end {writehooks} ;

    procedure SortByPSP(var Blocks : BlockArray; BlockNum : BlockType);
      {-sort in order of ascending PSP}
    var
      i, j : BlockType;
      temp : Block;
    begin
      for i := 1 to Pred(BlockNum) do
        for j := BlockNum downto Succ(i) do
          if Cardinal(Blocks[j].psp) < Cardinal(Blocks[Pred(j)].psp) then begin
            temp := Blocks[j];
            Blocks[j] := Blocks[Pred(j)];
            Blocks[Pred(j)] := temp;
          end;
    end {SortByPSP} ;

    procedure SumTheBlocks(var Blocks : BlockArray;
                           BlockNum : BlockType;
                           var Sum : BlockArray;
                           var SumNum : BlockType);
      {-combine the blocks with equivalent PSPs}
    var
      prevPSP : Integer;
      b : BlockType;
    begin
      SumNum := 0;
      prevPSP := 0;
      for b := 1 to BlockNum do begin
        if Blocks[b].psp <> prevPSP then begin
          SumNum := Succ(SumNum);
          Sum[SumNum] := Blocks[b];
          prevPSP := Blocks[b].psp;
          if prevPSP = CSeg then
            {don't include the environment as part of free block's length}
            Sum[SumNum].len := 0;
        end else
          with Sum[SumNum] do begin
            cnt := Succ(cnt);
            len := len+Blocks[b].len;
          end;
        {get length of the block which owns the executable program}
        {for checking vector trapping next}
        if Succ(Blocks[b].mcb) = Blocks[b].psp then
          Sum[SumNum].psplen := Blocks[b].len;
      end;
    end {sumblocks} ;

    procedure TransferTheBlocks(var Blocks : BlockArray;
                                BlockNum : BlockType;
                                var Sum : BlockArray;
                                var SumNum : BlockType);
      {-fill in the Sum array with a little initialization}
    var
      b : BlockType;
    begin
      for b := 1 to BlockNum do begin
        Sum[b] := Blocks[b];
        with Sum[b] do begin
          cnt := 1;
          if (Succ(mcb) = psp) and (psp <> 0) then
            psplen := len
          else
            psplen := 0;
        end;
      end;
      SumNum := BlockNum;
    end {transfertheblocks} ;

    function OpenHandles(psp : Integer) : Integer;
      {-return the number of open handles owned by a process}
    var
      h, o : Integer;
      b : Byte;
    begin
      h := 0;
      if (psp <> 8) and (cline <> 'N/A') then
        for o := 0 to 19 do begin
          b := Mem[psp:$18+o];
          if not(b in [$FF, 0..2]) then
            h := Succ(h);
        end;
      OpenHandles := h;
    end {openhandles} ;

    function CommandLine(psp : Integer) : Pathname;
      {-return the command line of the PSP}
    var
      t, s : Pathname;
      i : Byte;
    begin
      if (psp <> 8) then begin
        Move(Mem[psp:$80], t, 65);
        if t[0] > #64 then t[0] := #64;
        s := t;
        StripNonAscii(t);
        if s <> t then
          {command line has been written over}
          t := 'N/A'
        else
          {strip leading blanks}
          while (Length(t) > 0) and (t[1] = #32) do Delete(t, 1, 1);
      end else
        {psp=8 is a special block owned by DOS containing the CONFIG.SYS drivers}
        t := '';
      CommandLine := t;
    end {commandline} ;

    function PrevBlock(b : BlockType; psp : Integer) : BlockType;
      {-return highest block with number less than b having a PSP matching psp}
      {-return 0 if none}
    var
      t : BlockType;
      found : Boolean;
    begin
      found := False;
      t := Pred(b);
      while (t > 0) and not(found) do begin
        found := (Sum[t].psp = psp);
        if not(found) then t := Pred(t);
      end;
      PrevBlock := t;
    end {prevblock} ;

  begin
    WriteLn;
    Write('Allocated Memory Map - by TurboPower Software - Version ', Version);

    if verbose then begin
      WriteLn('  (verbose)');
      WriteLn;
      WriteLn(' PSP  MCB files bytes owner    command line  hooked vectors');
      WriteLn('---- ---- ----- ----- -------- ------------- -----------------------------');
    end else begin
      WriteLn;
      WriteLn;
      WriteLn(' PSP  blks bytes owner    command line        hooked vectors');
      WriteLn('----- ---- ----- -------- ------------------- ------------------------------');
    end;

    DOSv := DOSversion;
    CommandPSP := Blocks[2].psp;
    InitVectorTable;
    if verbose then
      TransferTheBlocks(Blocks, BlockNum, Sum, SumNum)
    else begin
      SortByPSP(Blocks, BlockNum);
      SumTheBlocks(Blocks, BlockNum, Sum, SumNum);
    end;

    for b := 1 to SumNum do with Sum[b] do begin

      {get the command line which invoked the program}
      if b = SumNum then
        cline := ''
      else
        cline := CommandLine(psp);

      {write out numerical information}
      Write(Hex(psp), ' ');   {PSP address}
      if verbose then begin
        Write(Hex(mcb), '  ', {MCB address}
        OpenHandles(psp):2, '  '); {number of open file handles}
      end else
        Write(cnt:3, '  ');   {number of blocks}

      Write(16.0*Cardinal(len):6:0, ' '); {size of block in bytes}

      {get the program owning this block by scanning the environment}
      if psp = CSeg then
        st := 'free'
      else if psp = CommandPSP then
        st := 'command'
      else if psp = Sum[1].psp then
        st := 'config'
      else if (DOSv >= 3) then begin
        if verbose then begin
          if Succ(mcb) = env then
            {this is the environment block}
            st := Owner(env)
          else if PrevBlock(b, psp) <> 0 then
            {this is the block that goes with the environment}
            st := Owner(Sum[PrevBlock(b, psp)].env)
          else
            st := 'N/A';
        end else if cnt > 1 then
          st := Owner(env)
        else
          st := 'N/A';
      end else
        st := 'N/A';
      while Length(st) < 9 do st := st+' ';
      Write(st);

      {write the command line that invoked the program}
      if verbose then
        StLen := 13
      else
        StLen := 19;
      if Length(cline) > StLen-3 then
        cline := Copy(cline, 1, StLen-3)+'...'
      else
        while Length(cline) < StLen do cline := cline+' ';
      Write(cline, ' ');

      {write the trapped interrupt vectors}
      if verbose or (b <> SumNum) then
        WriteHooks(psp, psp+psplen);

      WriteLn;
    end;

  end {showtheblocks} ;

  procedure ShowTheEMSblocks;
    {-map out expanded memory, if present}
  const
    EMSinterrupt = $67;       {the vector used by the expanded memory manager}
    MaxHandles = 255;

  type
    HandlePageRecord =
    record
      handle : Integer;
      numpages : Integer;
    end;

    PageArray = array[0..MaxHandles] of HandlePageRecord;
    PageArrayPtr = ^PageArray;
    Pathname = string[64];

  var
    EMSregs : registers;
    EMShandles : Integer;
    Map : PageArrayPtr;
    TotalPages : Integer;

    function EMSpresent : Boolean;
      {-return true if EMS memory manager is present}
    var
      f : file;
      present : Boolean;
    begin
      {"file handle" defined by the expanded memory manager at installation}
      Assign(f, 'EMMXXXX0');
      {$I-} Reset(f) {$I+} ;
      present := (IOResult = 0);
      if present then
        Close(f);
      EMSpresent := present;
    end {EMSpresent} ;

    function EMSpagesAvailable(var TotalPages : Integer) : Integer;
      {-return the number of 16K expanded memory pages available and unallocated}
    begin
      EMSregs.ah := $42;
      Intr(EMSinterrupt, EMSregs);
      if EMSregs.ah <> 0 then begin
        WriteLn('EMS device not responding');
        EMSpagesAvailable := 0;
        Exit;
      end;
      EMSpagesAvailable := EMSregs.bx;
      TotalPages := EMSregs.dx;
    end {EMSpagesAvailable} ;

    function EMShandlesActive : Integer;
      {-return the number of active EMS handles}
    begin
      EMSregs.ah := $4B;
      Intr(EMSinterrupt, EMSregs);
      if EMSregs.ah <> 0 then begin
        WriteLn('EMS device not responding');
        EMShandlesActive := 0;
        Exit;
      end;
      EMShandlesActive := EMSregs.bx;
    end {EMShandlesActive} ;

    procedure EMSpageMap(var PageMap : PageArray);
      {-return an array of the allocated memory blocks}
    begin
      EMSregs.ah := $4D;
      EMSregs.es := Seg(PageMap);
      EMSregs.di := Ofs(PageMap);
      EMSregs.bx := 0;
      Intr(EMSinterrupt, EMSregs);
      if EMSregs.ah <> 0 then
        WriteLn('EMS device not responding');
    end {EMSpageMap} ;

    procedure WriteEMSmap(PageMap : PageArray; handles : Integer);
      {-write out the EMS page map}
    var
      h : Integer;
    begin
      WriteLn('block   bytes   (Expanded Memory)');
      WriteLn('-----   ------');
      for h := 0 to Pred(handles) do
        WriteLn(h:5, '  ', (16384.0*Cardinal(PageMap[h].numpages)):7:0);
    end {writeEMSmap} ;

  begin
    if not(EMSpresent) then Exit;
    EMShandles := EMShandlesActive;
    WriteLn;
    GetMem(Map, 4*EMShandles);
    EMSpageMap(Map^);
    WriteEMSmap(Map^, EMShandles);
    WriteLn(' free  ', (16384.0*Cardinal(EMSpagesAvailable(TotalPages))):7:0);
    WriteLn('total  ', (16384.0*Cardinal(TotalPages)):7:0);
  end {showtheemsblocks} ;


begin
  verbose := False;
  if ParamCount > 0 then begin
    param := StUpcase(ParamStr(1));
    if (param = 'V') or (param = '-V') or (param = '/V') then
      verbose := True;
  end;
  FindTheBlocks;
  ShowTheBlocks;
  ShowTheEMSblocks;
end.